home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / mosmllib / Date.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  6.8 KB  |  202 lines  |  [TEXT/R*ch]
  1. (* Date -- 1995-07-03 *)
  2.  
  3. datatype weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun
  4.  
  5. datatype month
  6.   = Jan | Feb | Mar | Apr | May | Jun
  7.   | Jul | Aug | Sep | Oct | Nov | Dec
  8.  
  9. datatype date = DATE of {
  10.     year   : int,            (* e.g. 1995 *)
  11.     month  : month,
  12.     day    : int,               (* 1-31  *)
  13.     hour   : int,               (* 0-23  *)
  14.     minute : int,               (* 0-59  *)
  15.     second : int,               (* 0-61 (allowing for leap seconds) *)
  16.     wday   : weekday option,
  17.     yday   : int option,        (* 0-365 *)
  18.     isDst  : bool option        (* daylight savings time in force *)
  19.   }
  20.  
  21. exception Date
  22.  
  23. local 
  24.     type tmoz = {tm_hour   : int,
  25.          tm_isdst  : int,    (* 0 = no, 1 = yes, ~1 = don't know *)
  26.          tm_mday   : int,
  27.          tm_min    : int,
  28.          tm_mon    : int,
  29.          tm_sec    : int, 
  30.          tm_wday   : int,
  31.          tm_yday   : int,
  32.          tm_year   : int
  33.          }
  34.  
  35.     prim_val getlocaltime_ : real -> tmoz = 1 "sml_localtime";
  36.     prim_val getunivtime_  : real -> tmoz = 1 "sml_gmtime";
  37.     prim_val mktime_       : tmoz -> real = 1 "sml_mktime";
  38.  
  39.     prim_val asctime_  : tmoz -> string           = 1 "sml_asctime";
  40.     prim_val strftime_ : string -> tmoz -> string = 2 "sml_strftime";
  41.  
  42.     val toweekday = fn 0 => Sun | 1 => Mon | 2 => Tue | 3 => Wed
  43.                      | 4 => Thu | 5 => Fri | 6 => Sat 
  44.              | _ => raise Fail "Internal error: Date.toweekday";
  45.     val fromwday  = fn Sun => 0 | Mon => 1 | Tue => 2 | Wed => 3 
  46.                      | Thu => 4 | Fri => 5 | Sat => 6;
  47.     val tomonth   = fn 0 => Jan | 1 => Feb |  2 => Mar |  3 => Apr
  48.                      | 4 => May | 5 => Jun |  6 => Jul |  7 => Aug
  49.              | 8 => Sep | 9 => Oct | 10 => Nov | 11 => Dec
  50.              | _ => raise Fail "Internal error: Date.tomonth";
  51.     val frommonth = fn Jan => 0 | Feb => 1 | Mar => 2  | Apr => 3
  52.              | May => 4 | Jun => 5 | Jul => 6  | Aug => 7
  53.              | Sep => 8 | Oct => 9 | Nov => 10 | Dec => 11;
  54.     
  55.     fun tmozToDate {tm_hour, tm_isdst, tm_mday, tm_min, tm_mon, tm_sec,
  56.             tm_wday, tm_yday, tm_year} = 
  57.     DATE {year = tm_year + 1900, month = tomonth tm_mon, 
  58.           day = tm_mday, hour = tm_hour, minute = tm_min, 
  59.           second = tm_sec, wday = SOME (toweekday tm_wday),
  60.           yday = SOME tm_yday, 
  61.           isDst = case tm_isdst of 0 => SOME false 
  62.                                  | 1 => SOME true
  63.                                      | _ => NONE}
  64.  
  65.     fun okDate (DATE {year, month, day, hour, minute, second, yday, ...}) =
  66.     let fun leap y = 
  67.             y rem 4 = 0 andalso y rem 100 <> 0 orelse y rem 400 = 0;
  68.         val mthdays = fn Jan => 31 | Feb => if leap year then 29 else 28
  69.                     | Mar => 31 | Apr => 30 | May => 31 | Jun => 30
  70.             | Jul => 31 | Aug => 31 | Sep => 30 | Oct => 31
  71.             | Nov => 30 | Dec => 31;
  72.         val yeardays = if leap year then 366 else 365
  73.     in 
  74.              1900 <= year 
  75.             andalso 1 <= day    andalso day    <= mthdays month
  76.         andalso 0 <= hour   andalso hour   <= 23
  77.         andalso 0 <= minute andalso minute <= 59
  78.         andalso 0 <= second andalso second <= 61 (* leap seconds *)
  79.         andalso case yday of
  80.                  NONE    => true
  81.            | SOME yd => 0 <= yd andalso yd < yeardays
  82.     end;
  83.  
  84.     fun dateToTmoz (dt as DATE {year, month, day, hour, minute, second,
  85.                    wday, yday, isDst}) =
  86.     if okDate dt then 
  87.         {tm_hour = hour, tm_mday = day, tm_min = minute, 
  88.          tm_mon = frommonth month, tm_sec = second, 
  89.          tm_year = year - 1900, 
  90.          tm_isdst = case isDst of SOME false=>0 | SOME true=>1 | NONE=> ~1,
  91.           tm_wday = case wday of SOME w => fromwday w | NONE => 0,
  92.          tm_yday = case yday of SOME y => y | NONE => 0} 
  93.     else
  94.         raise Date;
  95.  
  96. in
  97.  
  98.     fun fromTime t = tmozToDate (getlocaltime_ (Time.timeToReal t));
  99.  
  100.     fun fromUTC t  = tmozToDate (getunivtime_ (Time.timeToReal t));
  101.  
  102.     (* The following implements conversion from a local date to 
  103.        a Time.time.  It IGNORES wday and yday.  *)
  104.  
  105.     fun toTime date = 
  106.     let val clock = mktime_ (dateToTmoz date)
  107.     in
  108.         if clock < 0.0 then raise Date
  109.         else Time.realToTime clock
  110.     end;
  111.  
  112.     fun toString date =
  113.     String.substring(asctime_ (dateToTmoz date), 0, 24) 
  114.     handle Fail _    => raise Date
  115.          | Subscript => raise (Fail "Date.toString: internal error");
  116.  
  117.     fun fmt fmtstr date =
  118.     (strftime_ fmtstr (dateToTmoz date)) 
  119.     handle Fail _ => raise Date
  120.  
  121.     (* To scan dates in the format "Wed Mar 08 19:06:45 1995" *)
  122.  
  123.     fun scan {getc :  'a -> (char * 'a) option} source =
  124.     let exception BadFormat
  125.         fun decval c = Char.ord c - 48
  126.         fun char wanted src = 
  127.         case getc src of
  128.             NONE           => raise BadFormat
  129.           | SOME (c, rest) => if c=wanted then rest 
  130.                       else raise BadFormat
  131.         fun getndig 0 res src = (res, src)
  132.           | getndig n res src = 
  133.         case getc src of
  134.             NONE           => raise BadFormat
  135.           | SOME (c, rest) => 
  136.             if Char.isDigit c then 
  137.                 getndig (n-1) (10 * res + decval c) rest
  138.             else 
  139.                 raise BadFormat
  140.         fun getnalf 0 res src = (String.implode (List.rev res), src)
  141.           | getnalf n res src = 
  142.         case getc src of
  143.             NONE           => raise BadFormat
  144.           | SOME (c, rest) => 
  145.             if Char.isAlpha c then getnalf (n-1) (c :: res) rest
  146.             else raise BadFormat
  147.  
  148.         val get2dig = getndig 2 0
  149.         val get4dig = getndig 4 0
  150.         val get3alf = getnalf 3 []
  151.  
  152.         val getMonth = fn "Jan" => Jan | "Feb" => Feb | "Mar" => Mar
  153.                 | "Apr" => Apr | "May" => May | "Jun" => Jun
  154.                 | "Jul" => Jul | "Aug" => Aug | "Sep" => Sep
  155.                 | "Oct" => Oct | "Nov" => Nov | "Dec" => Dec
  156.                 | _ => raise BadFormat
  157.         val getWday  = fn "Sun" => Sun | "Mon" => Mon | "Tue" => Tue
  158.                 | "Wed" => Wed | "Thu" => Thu | "Fri" => Fri
  159.                 | "Sat" => Sat | _ => raise BadFormat
  160.     in 
  161.         let val src          = StringCvt.skipWS {getc = getc} source
  162.         val (wday, src)  = get3alf src
  163.         val src          = char #" " src
  164.         val (month, src) = get3alf src
  165.         val src          = char #" " src
  166.         val (day, src)   = get2dig src
  167.         val src          = char #" " src
  168.         val (hour, src)  = get2dig src
  169.         val src          = char #":" src
  170.         val (min, src)   = get2dig src
  171.         val src          = char #":" src
  172.         val (sec, src)   = get2dig src
  173.         val src          = char #" " src
  174.         val (year, rest) = get4dig src
  175.         in SOME (DATE {year = year, month = getMonth month, 
  176.                day = day,  hour = hour, minute = min, 
  177.                second = sec, wday = SOME (getWday wday), 
  178.                yday = NONE, isDst = NONE}, rest)
  179.         end
  180.         handle BadFormat => NONE
  181.     end;
  182.  
  183.     fun fromString s = StringCvt.scanString scan s
  184.  
  185.     fun compare 
  186.     (DATE {year=y1,month=mo1,day=d1,hour=h1,minute=mi1,second=s1, ...},
  187.      DATE {year=y2,month=mo2,day=d2,hour=h2,minute=mi2,second=s2, ...}) =
  188.     let fun cmp(v1, v2, cmpnext) = 
  189.         if v1 < v2 then LESS 
  190.         else if v1 > v2 then GREATER
  191.         else (* EQUAL *) cmpnext ()
  192.     in 
  193.         cmp(y1, y2, 
  194.         fn _ => cmp(frommonth mo1, frommonth mo2, 
  195.         fn _ => cmp(d1, d2,         
  196.         fn _ => cmp(h1, h2,
  197.         fn _ => cmp(mi1, mi2,
  198.         fn _ => cmp(s1, s2,
  199.         fn _ => EQUAL))))))
  200.     end
  201. end
  202.